Visual Basic Controls/Visual Basic Controls.iso/vbcontrol/cpkocx17/support.bas

BASIC Source File | 1997-06-01 | 23.2 KB | 803 lines

Attribute VB_Name = "SUPPORT"
'
' Support.bas
'
' This file contains support functions and subroutines
'
' Misc functions that didn't fit anywhere else...
'
Option Explicit

' Screen.MousePointers
Const HOURGLASS = 11         ' 11 - Hourglass

' MsgBox parameters
Const MB_ICONSTOP = 16       ' Critical message


' Application-wide variables
Global App_Done As Integer


' ---- Net DDE support ----

' Here are the permissions allowed for dwPermissions:
Global Const NDDEACCESS_REQUEST = &H1          'Allows LinkRequest
Global Const NDDEACCESS_ADVISE = &H2           'Allows LinkAdvise
Global Const NDDEACCESS_POKE = &H4             'Allows LinkPoke
Global Const NDDEACCESS_EXECUTE = &H8          'Allows LinkExecute
Global Const NDDEACCESS_START_APP = &H10       'Starts source application on connect

Global Const MAX_NDDESHARENAME_PLUSONE = 65

Type NDDESHAREINFO
    szShareName As String * MAX_NDDESHARENAME_PLUSONE
    lpszTargetApp As Long    'LPSTR lpszTargetApp
    lpszTargetTopic As Long  'LPSTR lpszTargetTopic
    lpbPassword1 As Long     'LPBYTE lpbPassword1
    cbPassword1 As Long      'DWORD  cbPassword1;
    dwPermissions1 As Long   'DWORD  dwPermissions1;
    lpbPassword2 As Long     'LPBYTE lpbPassword2;
    cbPassword2 As Long      'DWORD  cbPassword2;
    dwPermissions2  As Long  'DWORD  dwPermissions2;
    lpszItem As Long         'LPSTR  lpszItem;
    cAddItems As Long        'LONG   cAddItems;
    lpNDdeShareItemInfo As Long
End Type

#If Win16 Then
Declare Function NDdeGetWindow Lib "nddeapi.DLL" () As Integer
Declare Function NDdeShareAdd Lib "nddeapi.DLL" (Server As Any, ByVal level As Integer, ShareInfo As NDDESHAREINFO, ByVal nSize As Long) As Integer
Declare Function NDdeShareDel Lib "nddeapi.DLL" (lpszServer As Any, ByVal lpszShareName As String, ByVal wReserved As Integer) As Integer
Declare Function NDdeGetNodeName Lib "nddeapi.DLL" (ByVal lpszNodeName As String, ByVal cNodeNameLimit As Long) As Long
Declare Function NDdeShareGetInfo Lib "nddeapi.DLL" (ByVal lpszServer As String, ByVal lpszShareName As String, ByVal nLevel As Integer, lpBuf As NDDESHAREINFO, ByVal cBufSz As Long, lpnTotAvail As Long, ByVal lpnItems As Integer) As Integer
Declare Function NDdeGetClientInfo Lib "nddeapi.DLL" (ByVal hWndClient As Integer, ByVal lpszClientNode As String, ByVal cClientNodeLimit As Long, ByVal lpszClientApp As String, ByVal cClientAppLimit As Long) As Integer

Declare Function lstrcpy Lib "kernel" (szDest As Any, szSource As Any) As Long
#Else
Declare Function NDdeGetWindow Lib "nddeapi.DLL" () As Integer
Declare Function NDdeShareAdd Lib "nddeapi.DLL" (Server As Any, ByVal level As Integer, ShareInfo As NDDESHAREINFO, ByVal nSize As Long) As Integer
Declare Function NDdeShareDel Lib "nddeapi.DLL" (lpszServer As Any, ByVal lpszShareName As String, ByVal wReserved As Integer) As Integer
Declare Function NDdeGetNodeName Lib "nddeapi.DLL" (ByVal lpszNodeName As String, ByVal cNodeNameLimit As Long) As Long
Declare Function NDdeShareGetInfo Lib "nddeapi.DLL" (ByVal lpszServer As String, ByVal lpszShareName As String, ByVal nLevel As Integer, lpBuf As NDDESHAREINFO, ByVal cBufSz As Long, lpnTotAvail As Long, ByVal lpnItems As Integer) As Integer
Declare Function NDdeGetClientInfo Lib "nddeapi.DLL" (ByVal hWndClient As Integer, ByVal lpszClientNode As String, ByVal cClientNodeLimit As Long, ByVal lpszClientApp As String, ByVal cClientAppLimit As Long) As Integer

Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (szDest As Any, szSource As Any) As Long
#End If


'Here are the possible return values from NDdeShareAdd():
Global Const NDDE_NO_ERROR = 0                 'No error.
Global Const NDDE_BUF_TOO_SMALL = 2            'Buffer is too small to hold information.
Global Const NDDE_INVALID_APPNAME = 13         'Application name is not valid.
Global Const NDDE_INVALID_ITEMNAME = 9         'Item name is not valid.
Global Const NDDE_INVALID_LEVEL = 7            'Invalid level; nLevel parameter must be 2.
Global Const NDDE_INVALID_PASSWORD = 8         'Password is not valid.
Global Const NDDE_INVALID_SERVER = 4           'Computer name is not valid;

Global Const NDDE_INVALID_SHARE = 5            'Share name is not valid.
Global Const NDDE_INVALID_TOPIC = 10           'Topic name is not valid.
Global Const NDDE_OUT_OF_MEMORY = 12           'Not enough memory to complete request.
Global Const NDDE_ALREADY_EXISTS = 15           'Existing shares cannot be replaced.

'
' Catenate a new part (file or directory) to an
' existing file system path
'
Function AddPart$(Path$, Part$)
    Dim c$

    ' If path not null
    If Path$ <> "" Then
        c$ = Mid$(Path$, Len(Path$), 1)

        If c$ <> ":" And c$ <> "\" Then
            Path$ = Path$ & "\"
        End If
    End If

    AddPart$ = Path$ & Part$

End Function

Sub App_Close(f As Form)
    Help_Close
    Options_Write f
End Sub

Sub App_Init(f As Form)
    Help_Init

    Options_Read f
    Game_Clear

    If Command$ <> "" Then
        Game_Open (Command$)
    End If

    App_Done = False

End Sub

'
' This function asks the user whether he wants to overwrite an
' existing file.
'
' Returns IDYES, IDNO or IDCANCEL
'
' In case of IDNO, the caller should re-prompt the user for a
' different file name.
'
Function AskOverWrite(FileName$) As Integer
    Dim Msg As String

    Msg = "File '" & FileName$ & "' already exists." & Chr$(10)
    Msg = Msg & "Do you want to replace it with the new file?"

    AskOverWrite = MsgBox(Msg, MB_YESNOCANCEL + MB_ICONQUESTION, App.Title)
End Function

'
' Test whether the specified file exists.
' Returns True or False
'
Function FileExists(fname$) As Integer
    Dim S$

    S$ = Dir$(fname$)

    If S$ <> "" Then
        FileExists = True
    Else
        FileExists = False
    End If
End Function

'
' Extract "file.ext" part from a complex pathname,
' such as X:\foo\bar\file.ext
'
' Returns the 'file part' string
'
Function FilePart$(P$)
    Dim I As Integer, L As Integer
    Dim f As String, c As String

    FilePart$ = P$

    L = Len(P$)

    ' scan the pathname backwards, stopping at
    ' the first path delimiter character
    For I = L To 1 Step -1
        c = Mid$(P$, I, 1)
        If c = ":" Or c = "\" Then
            FilePart$ = Mid$(P$, I + 1)     ' return string at right side of delimiter
            Exit Function
        End If
    Next I


End Function

'
' This subroutine centers a form on the screen.
'
' Typical use is in a Form LOAD method.
'
Sub Form_Center(f As Form)

    f.Left = (Screen.Width - f.Width) \ 2
    f.Top = (Screen.Height - f.Height) \ 2

End Sub

Sub Form_SetTitle(f As Form)
    f.Caption = App.Title & " - " & FilePart$(Game_FileName$)
End Sub

'
' Close the help tool if any was open for this program
'
Sub Help_Close()
    On Error Resume Next
    WinHelp Screen.ActiveForm.hWnd, App.HelpFile, HELP_QUIT, CLng(0)
End Sub

Sub Help_Conts()
    WinHelp Screen.ActiveForm.hWnd, App.HelpFile, APP_HELP_CONTENTS, CLng(0)
End Sub

'
' Converts a relative help file path into an
' absolute path name. This allows us to find the help
' file even if we move later on.
'
' NOTE: The start-up working directory should have been set
'       to the dir where the executable is located FROM THE
'       WINDOWS PROGRAM MANAGER. Failure to do so will cause
'       the program to start with WINDOWS as the current dir.
'
' This sub should be called first thing in the program,
' that is in Sub Main() or in the first Form_Load()
'
Sub Help_Init()
    Dim D$, f$

    D$ = CurDir$        '
    f$ = App.HelpFile   ' should be a path relative to the startup dir

    ' combine the 2 paths intelligently, accounting for
    ' path that climb and descend, to specify an adjacent directory.
    ' e.g.:
    '   start-up dir            = "C:\a\b\c"
    '   rel. path to help file  = "..\..\d\x.hlp"
    '   abs. path to help file  = "C:\a\d\x.hlp"

    While InStr(f$, "..\") > 0  ' path goes up
        f$ = Mid$(f$, 4)        ' remove climb to parent
        D$ = PathPart$(D$)      ' remove one level from current dir
    Wend

    App.HelpFile = AddPart$(D$, f$)
End Sub

'
' Display WinHelp search dialog
'
Sub Help_Search(key$)
    WinHelpString Screen.ActiveForm.hWnd, App.HelpFile, HELP_PARTIALKEY, key$
End Sub

'
' Open the help tool, showing a specific topic
'
Sub Help_Show(Topic As Integer)
    WinHelp Screen.ActiveForm.hWnd, App.HelpFile, HELP_CONTEXT, CLng(Topic)
End Sub

'
' Open the help tool, show the page about using the
' help system itself.
'
Sub Help_UsingHelp()
    WinHelp Screen.ActiveForm.hWnd, App.HelpFile, HELP_HELPONHELP, CLng(0)
End Sub

' Get a whole line of text from a file, stopping at
' new line or EOF.
'
' Apparently, VB does not have a variant of Input #
' that can read a whole line, up to the CR/LF
' regardless of the contains (if it can, I didn't
' find it).
'
Function InputLine$(f As Integer)
    Dim S As String, c As String
    Dim LF As String, CR As String

    CR = Chr$(13)
    LF = Chr$(10)

    S = ""

    Do While Not EOF(f)
        c = Input$(1, #f)
        If c <> LF And c <> CR Then S = S & c
        If c = CR Then Exit Do
    Loop

    InputLine$ = S

End Function

'
' Returns True if char C is in set CSet
'
Function IsInCharSet(c As String, CSet As String) As Integer
    Dim n As Integer, I As Integer

    n = Len(CSet)
    IsInCharSet = False

    For I = 1 To n
        If Mid$(CSet, I, 1) = c Then
            IsInCharSet = True
            Exit Function
        End If
    Next I

End Function


Sub NDDEConnect(c As Control, Computer As String, Topic As String, Item As String)

    Dim r As Long

    'Debug.Print "NDDEConnect: trying "; Item

    ' The link topic identifies the computer name and link topic
    ' as established by the DDE source application
    c.LinkMode = 0      ' turn off link just in case it's up



    ' NOTE WELL:
    ' You can debug the network game via DDE on one computer,
    ' Run Copy 1, compiled as 'peer.exe', with the following line set to 'briscola|game'
    ' Run Copy 2, from within VB, with the following line set to 'peer|game'
    c.LinkTopic = "zot|game"

    ' c.LinkTopic = "\\" & Computer & "\" & "NDDE$" & "|" + Topic


    c.LinkItem = Item   ' Name of text box in DDE source app
    c.LinkMode = 1      ' Automatic link.

    'Debug.Print "NDDEConnect: linked "; Item

End Sub

Function NDDEListen(szShare As String, szTargetName As String, szTopic As String) As Integer

      Dim szItemName As String
      Dim szReadOnlyPassword As String ' Read-only pw Net DDE share
      Dim szFullAccessPassword As String ' Full access password
      Dim ShareInfo As NDDESHAREINFO


On Error GoTo nddel_err
      szShare = szShare + Chr$(0)
      szTargetName = szTargetName + Chr$(0)
      szTopic = szTopic + Chr$(0)
      szItemName = Chr$(0)                    'All items are allowed
      szReadOnlyPassword = Chr$(0)            'No password
      szFullAccessPassword = Chr$(0)

      'Provide the share, target, topic, and item names along with
      'passwords that identify the network DDE share
      ShareInfo.szShareName = szShare
      ShareInfo.lpszTargetApp = lstrcpy(ByVal szTargetName, ByVal szTargetName)
      ShareInfo.lpszTargetTopic = lstrcpy(ByVal szTopic, ByVal szTopic)
      ShareInfo.lpszItem = lstrcpy(ByVal szItemName, ByVal szItemName)
      ShareInfo.cbPassword1 = 0
      ShareInfo.lpbPassword1 = lstrcpy(ByVal szReadOnlyPassword, ByVal szReadOnlyPassword)
      ShareInfo.dwPermissions1 = NDDEACCESS_REQUEST Or NDDEACCESS_ADVISE Or NDDEACCESS_POKE Or NDDEACCESS_EXECUTE Or NDDEACCESS_START_APP
      ShareInfo.cbPassword2 = 0
      ShareInfo.lpbPassword2 = lstrcpy(ByVal szFullAccessPassword, ByVal szFullAccessPassword)
      ShareInfo.dwPermissions2 = NDDEACCESS_REQUEST Or NDDEACCESS_ADVISE Or NDDEACCESS_POKE Or NDDEACCESS_EXECUTE Or NDDEACCESS_START_APP
      ShareInfo.lpNDdeShareItemInfo = 15

      NDDEListen = NDdeShareAdd(ByVal 0&, 2, ShareInfo, Len(ShareInfo))
      Exit Function

nddel_err:
      NDDEListen = -1
      Exit Function

End Function

Function NetBrowseHost$()
    NetBrowseHost$ = InputBox("Enter Destination Computer", "Briscola", "")
End Function

Function NetHostName$()
    Dim S$, r%

    'On Error GoTo net_err
    S$ = Space$(255)
    r% = NDdeGetNodeName(S$, Len(S$))

    For r% = 1 To Len(S$)
        If Mid$(S$, r%, 1) = Chr$(0) Then Exit For
    Next r%
    NetHostName$ = Left$(S$, r% - 1)
    Exit Function

net_err:

    NetHostName$ = InputBox("Enter name of this Computer", "Briscola", "")
    Exit Function
End Function

'
' Splits string S in words, putting them in the wd_parsed()
' array. Words are delimited by "blanks", as defined
' by character set Bln.
'
' The max number of words that will be stored is limited
' by the size of the wd_parsed array.
'
' Returns the number of words stored.
'
Function Parse(S As String, Bln As String, wd_parsed() As String) As Integer

    Dim L As Integer, c As String, I As Integer
    Dim wd_min As Integer, wd_max As Integer        ' bounds of the passed array
    Dim wd_num As Integer                           ' words parsed so far

    Dim wd_start As Integer, wd_end As Integer      ' bounds of current word
    Dim wd_len As Integer



    L = Len(S)
    I = 1
    wd_num = 0

    ' get bounds of the wd_parsed array
    wd_min = LBound(wd_parsed, 1)
    wd_max = UBound(wd_parsed, 1)

    Do
        wd_start = 0        ' no word found
        wd_end = 0


        ' extract a word
        Do
            c = Mid$(S, I, 1)

            If IsInCharSet(c, Bln) = True Then      ' C is a blank
                If wd_start > 0 Then wd_end = I - 1 ' Mark word as terminated (if any)
            Else                                    ' C is not a blank
                If wd_start = 0 Then wd_start = I   ' Mark start of a new word (if none)
            End If

            I = I + 1

        Loop While (wd_end = 0 And I <= L)          ' until EOS or whole word retrieved


        ' if a word was extracted, try to store it in the result array
        If wd_start > 0 Then
            If wd_end = 0 Then wd_end = L           ' word was unterminated:
                                                    ' no trailing blanks found, take
                                                    ' EOWord = EOS
            wd_len = wd_end - wd_start + 1

            ' if room is left in the wd_parsed array and the word is not empty,
            ' store the word in the array
            If wd_len > 0 And wd_num < (wd_max - wd_min + 1) Then
                wd_parsed(wd_min + wd_num) = Mid$(S, wd_start, wd_len)
                wd_num = wd_num + 1
            End If
        End If

    Loop While (I <= L)                             ' continue until EOS

    Parse = wd_num                                  ' return # words stored

End Function

'
' Extract "D:\dir\dir\" part from a complex pathname
'
' This function also takes care of some VB oddities,
' making sure that the returned path is legal for
' use with 'ChDir'
'
' See Also 'FilePart$()'
'
Function PathPart$(P$)
    Dim L, I As Integer
    Dim c As String
    Dim Pt As String

    L = Len(P$)


    ' scan the string backwards, until a path delimiter is found
    For I = L To 1 Step -1
       c = Mid$(P$, I, 1)
       If c = "\" Or c = ":" Then Exit For
    Next I

    ' extract the 'path part' at the left of the delimiter
    Pt = Left$(P$, I)


    ' Now check for some weird path formats that
    ' ChDir can and others it can't handle
    L = Len(Pt)

    ' a terminal "\" is legal only for "root dir"
    If L > 1 And Mid$(Pt, L, 1) = "\" Then              ' a terminal '\'
        If Mid$(Pt, L - 1, 1) <> ":" Then               ' but not ':\'
            Pt = Left$(Pt, L - 1)                       ' if so, kill the '\'
        End If
    End If

    PathPart$ = Pt

End Function

'
' Returns position of 1st occurrence of 1 char
' from character set CSset in string S, starting the scan at I
'
' Almost like InStr(), but does not look for a substring,
' looks for chars in a given character set!
'
' A return value of 0 means 'no char from set CSet was found in string'
'
' See Also: 'PosDiff()'
'
Function Pos(S As String, CSet As String, I As Integer) As Integer

    Dim L As Integer, j As Integer

    L = Len(S)
    Pos = 0

    If I < 1 Or I > L Then Exit Function                    ' skip obvious illegalities

    For j = I To L                                          ' For each char in string
        If IsInCharSet(Mid$(S, j, 1), CSet) = True Then
            Pos = j
            Exit Function
        End If
    Next j

End Function

'
' Returns position in string S of 1st occurrence of any char
' DIFFERENT from those in set CSet, starting the scan at I
'
' See Also: 'Pos()'
'
Function PosDiff(S As String, CSet As String, I As Integer) As Integer
    Dim L As Integer, j As Integer

    L = Len(S)
    PosDiff = 0

    If I < 1 Or I > L Then Exit Function                    ' purge illegal vals

    For j = I To L                                          ' For each char in string
        If IsInCharSet(Mid$(S, j, 1), CSet) = False Then
            PosDiff = j
            Exit Function
        End If

    Next j

End Function

Function Profile_ReadBool(Sect$, key$, Def%) As Integer

    Dim S$, D$

    If Def% Then
        D$ = "yes"
    Else
        D$ = "no"
    End If

    S$ = Profile_ReadString$(Sect$, key$, D$)

    Select Case UCase$(S$)
        Case "Y", "TRUE", "YES", "1"
            Profile_ReadBool = True
        Case Else
            Profile_ReadBool = False
    End Select

End Function

Function Profile_ReadInt(Sect$, key$, Def%) As Integer
    Profile_ReadInt = GetPrivateProfileInt(Sect$, key$, Def%, App_Profile)
End Function

Function Profile_ReadString$(Sect$, key$, Def$)
    Dim S$, r%

    S$ = Space$(100)                        ' prepare an empty buffer space
    r% = GetPrivateProfileString(Sect$, key$, Def$, S$, 100, App_Profile)
    Profile_ReadString$ = StringTrim(S$)    ' remove excess spaces

End Function

Sub Profile_WriteBool(Sect$, key$, I%)

    If I% Then
        Profile_WriteString Sect$, key$, "yes"
    Else
        Profile_WriteString Sect$, key$, "no"
    End If
End Sub

Sub Profile_WriteInt(Sect$, key$, I%)
    Profile_WriteString Sect$, key$, Format$(I%)
End Sub

Sub Profile_WriteString(Sect$, key$, What$)
    Dim r%

    r% = WritePrivateProfileString(Sect$, key$, What$, App_Profile)

End Sub

'
'
Sub RecentFile_AddItem(f As Form, fname$)

    Dim I%, Slot%
    Dim r As Control, S$

    ' Do this only if file is different from the most recent one
    If fname$ = RecentFile_Item$(f, 1) Then Exit Sub

    ' Make sure the separator line before names is visible
    f.FileRecent(0).Visible = True

    ' Remove file from the list if already there before adding to top
    For Slot% = 1 To 3                  ' last slot (4) would be discarded anyway
        S$ = RecentFile_Item$(f, I%)
        If S$ = fname$ Then Exit For    ' Will shift list only this far
    Next Slot%


    ' Shift down the list. Make sure the shifted down items are visible
    For I% = Slot% To 2 Step -1

        S$ = RecentFile_Item(f, I% - 1)

        If S$ <> "" Then
            f.FileRecent(I%).Caption = RecentFile_Format$(S$, I%)
            f.FileRecent(I%).Visible = True
        End If

    Next I%


    ' Finally, set the name to the top slot.
    Set r = f.FileRecent(1)
    r.Caption = RecentFile_Format$(fname$, 1)
    r.Visible = True

End Sub

Function RecentFile_Format$(fname$, I%)
    RecentFile_Format = "&" & Trim$(Str$(I%)) & " " & fname$
End Function

Function RecentFile_Item$(f As Form, I%)
    RecentFile_Item$ = Mid$(f.FileRecent(I%).Caption, 4)
End Function

'
' Read recent file entry from profile, if any add it to the
' menu with a number tag and make sure that the separator is
' visible
'
Sub RecentFile_Read(f As Form)
    Dim I%, S$

    For I% = 1 To 4
        S$ = Profile_ReadString$(SEC_GLOBAL, "RecentFile" & Trim$(Str$(I%)), "")

        If S$ <> "" Then
            f.FileRecent(I%).Caption = RecentFile_Format$(S$, I%)
            f.FileRecent(I%).Visible = True

            ' lines before the list of files
            f.FileRecent(0).Visible = True

        End If
    Next I%

End Sub

Sub RecentFile_Write(f As Form)
    Dim I%

    For I% = 1 To 4
        Profile_WriteString SEC_GLOBAL, "RecentFile" & Trim$(Str$(I%)), RecentFile_Item(f, I%)
    Next I%

End Sub

'
' Replace in string S every occurrence of characters from
' character set CSet with RStr string.
'
' This function is a more general solution to the problem
' where you want the user to input names and data in free
' format and then automatically replace illegal characters
' (i.e. substitute underscores for blanks).
'
' Returns the converted string.
'
' Example: Replace$("abc abc", "bc", "_") --> "a__ a__"
'
Function Replace$(S As String, CSet As String, RStr As String)
    Dim r As String
    Dim I As Integer, L As Integer

    r = S
    L = Len(r)

    For I = 1 To L
        If IsInCharSet(Mid$(r, I, 1), CSet) = True Then
             r = Left$(r, I - 1) & RStr & Mid$(r, I + 1)
        End If
    Next I

    Replace$ = r

End Function

'
' This function prompts the user with a modal dialog
' showing the title of the application, the passed
' message, and a STOP icon.
'
' If the global VB variable 'Err' is set due to
' a real VB run-time error, the corresponding message
' is appended to the passed message and also shown
' in the dialog.
'
Sub ReportError(Msg$)
    Dim S As String, LF As String

    LF = Chr$(10)

    S = "Error!" & LF & LF & Msg$
    If Err > 0 Then
        S = S & LF & LF & "Reason:  " & Error$
    End If

    MsgBox S, MB_ICONSTOP, App.Title
End Sub

Function StringTrim(Str1 As String) As String
    Dim S$

    S$ = Trim$(Str1)

    If Right$(S$, 1) = Chr$(0) Then
        S$ = Left$(S$, Len(S$) - 1)
    End If

    S$ = Trim$(S$)

    StringTrim = S$

End Function

'
' Strip passed string of leading and trailing blanks.
'
' Blanks are defined as the characters in set BSet
'
Function Strip$(S As String, BSet As String)
    Dim r As String
    Dim I As Integer, L As Integer

    r = S
    L = Len(r)


    ' Loop until a non-blank char is found
    For I = 1 To L
        If IsInCharSet(Mid$(r, I, 1), BSet) = False Then Exit For
    Next I

    ' If any blanks were found, keep right part of string.
    If I > 1 Then r = Mid$(r, I)

    L = Len(r)

    For I = L To 1 Step -1
        If IsInCharSet(Mid$(r, I, 1), BSet) = False Then Exit For
    Next I

    If I < L Then r = Left$(r, I)

    Strip$ = r

End Function